#lang racket


(require "../ast/main.rkt"
         "../base/main.rkt")

(provide define-impl-method
         define-impl-methods)

(provide generic-proxy%)

(define-syntax define-abstract-method
  (syntax-rules ()
    ((_ name)
     (define/public (name . args)
       (error 'name "not implemented")))))

(define-syntax define-abstract-methods
  (syntax-rules ()
    ((_ x ...)
     (begin
       (define-abstract-method x) ...))))

(define-syntax (define-impl-method stx)
  (syntax-case stx ()
    ((ctx (name arg ...) impl)
     #`(define/override (name arg ...)
         (#,(datum->syntax #'ctx #'impl) arg ...)))))

(define-syntax define-impl-methods
  (syntax-rules ()
    ((_ (x ...) ...)
     (begin
       (define-impl-method x ...) ...))))


; lang

; generic proxy

(define generic-proxy%
  (class* object% ()
    (super-new)

    (define-abstract-methods
      ; shapes
      bbox
      
      ; points
      point
      
      point?
      
      point-c
      
      ; lines
      arc
      elliptical-arc
      ellipse
      line
      nurbs-curve
      spline
      
      line?
      line-closed?
      polygonal-line?
      
      line-begin-c
      line-cs
      line-end-c
      
      ; surfaces
      donut
      ngon
      nurbs-surface
      star
      surface
      
      surface?
      
      surface-curvature
      surface-domain
      
      ; solids
      box
      cone
      cone-frustum
      cylinder
      pyramid
      sphere
      
      solid?
      
      ; generic shapes
      circle
      rectangle
      
      ; text
      text
      
      ; transformations 
      extrude
      intersect
      join
      loft
      move
      offset
      rotate
      scale
      section
      slice
      subtract
      sweep
      thicken
      union)

    
    ; lang
    
    ; align
    
    (define (bb-fn<-key-align-type key-align-type)
      (match key-align-type
        ((center-key-align-type) bbox-center)
        ((x-pos-key-align-type) bbox-x-pos)
        ((x-neg-key-align-type) bbox-x-neg)
        ((y-pos-key-align-type) bbox-y-pos)
        ((y-neg-key-align-type) bbox-y-neg)
        ((z-pos-key-align-type) bbox-z-pos)
        ((z-neg-key-align-type) bbox-z-neg)))
    
    (define (bb-fn<-shape-align-type shape-align-type)
      (match shape-align-type
        ((x-cen-shape-align-type) bbox-center)
        ((x-pos-shape-align-type) bbox-x-pos)
        ((x-neg-shape-align-type) bbox-x-neg)
        ((y-cen-shape-align-type) bbox-center)
        ((y-pos-shape-align-type) bbox-y-pos)
        ((y-neg-shape-align-type) bbox-y-neg)
        ((z-cen-shape-align-type) bbox-center)
        ((z-pos-shape-align-type) bbox-z-pos)
        ((z-neg-shape-align-type) bbox-z-neg)))
    
    (define (sub-*-c fn xyz-fn c1 c2)
      (fn (- (xyz-fn (sub-c c2 c1)))))
    
    (define sub-x-c (cλ sub-*-c x xyz-x))
    (define sub-y-c (cλ sub-*-c y xyz-y))
    (define sub-z-c (cλ sub-*-c z xyz-z))
    
    (define (sub-fn<-shape-align-type shape-align-type)
      (match shape-align-type
        ((x-cen-shape-align-type) sub-x-c)
        ((x-pos-shape-align-type) sub-x-c)
        ((x-neg-shape-align-type) sub-x-c)
        ((y-cen-shape-align-type) sub-y-c)
        ((y-pos-shape-align-type) sub-y-c)
        ((y-neg-shape-align-type) sub-y-c)
        ((z-cen-shape-align-type) sub-z-c)
        ((z-pos-shape-align-type) sub-z-c)
        ((z-neg-shape-align-type) sub-z-c)))
    
    (define (align-shape sub-fn key-bb key-bb-fn shape-bb-fn shape)
      (let ((bb (send this bbox (send this clone-shape shape))))
        (send this move (sub-fn (key-bb-fn key-bb) (shape-bb-fn bb)) shape)))
    
    (define (align-shapes key-bb key-align-types shape-align-types shapes)
      (for/list ((key-align-type key-align-types)
                 (shape-align-type shape-align-types)
                 (shape shapes))
        (align-shape
         (sub-fn<-shape-align-type shape-align-type)
         key-bb
         (bb-fn<-key-align-type key-align-type)
         (bb-fn<-shape-align-type shape-align-type)
         shape)))
    
    (define/public (align key-align-types key-shape shape-align-types shapes)
      (let ((key-bb (send this bbox (send this clone-shape key-shape))))
        (let ((aligned-shapes (align-shapes key-bb key-align-types shape-align-types shapes)))
          (cons key-shape aligned-shapes))))
    
    ; /align
    
    
    (define/public (parametric functional-par)
      (match functional-par
        ((functional-curve fn t0 t1)
         (send this spline #f (generate-curve-points fn t0 t1) (auto-spline-type)))))

    (define-abstract-method lift)
    
    
    ; on
    
    (define (on-shape corner-fn bbox-fn shape1 shape2)
      (let* ((bb1 (send this bbox (send this clone-shape shape1)))
             (bb2 (send this bbox (send this clone-shape shape2)))
             (corner (corner-fn bb2))
             (center (bbox-fn bb1 corner)))
        (send this move (sub-c center (bbox-center bb1)) shape1)))
    
    (define (on-shapes corner-fn bbox-fn shapes)
      (define (on-shapes-rec shapes oned-shapes)
        (if (empty? shapes)
            oned-shapes
            (let ((oned-shape (on-shape corner-fn bbox-fn (first shapes) (first oned-shapes))))
              (on-shapes-rec (rest shapes) (cons oned-shape oned-shapes)))))
      (let ((rev-shapes (reverse shapes)))
        (on-shapes-rec (rest rev-shapes) (list (first rev-shapes)))))
    
    (define (on-impl type shapes)
      (match type
        ((x-pos-on-type) (on-shapes bbox-x-pos bbox-center<-left shapes))
        ((x-neg-on-type) (on-shapes bbox-x-neg bbox-center<-right shapes))
        ((y-pos-on-type) (on-shapes bbox-y-pos bbox-center<-front shapes))
        ((y-neg-on-type) (on-shapes bbox-y-neg bbox-center<-back shapes))
        ((z-pos-on-type) (on-shapes bbox-z-pos bbox-center<-bottom shapes))
        ((z-neg-on-type) (on-shapes bbox-z-neg bbox-center<-top shapes))))
    
    (define/public (on type shapes)
      (on-impl type shapes))
    
    ; /on

    (define-abstract-methods
      ; lang
      par
      
      ; cad
      clone-shape
      clone-shapes
      delete-shape
      delete-shapes
      get-shapes
      layer
      prompt-point
      prompt-shape
      render-shapes
      select-shape
      select-shapes
      unselect-all-shapes
      view
      valid-shape?)))